Developer CD Series 1994…tember: Reference Library/Dev.CD Sep 94.toast/Periodicals/develop/develop Issue 16/develop 16 code/Number Formatting/Numbers.p

Text File | 1993-09-15 | 15.1 KB | 597 lines | [TEXT/MPS ]

PROGRAM Numbers;

    USES
        Script, Resources, Memory, Errors, GestaltEqu, Packages, SANE, UFailure;

    VAR
        gDefaultDecimalSeparator: Char;
        gDefaultThousandsSeparator: Char;


    PROCEDURE InitializeDefaultNumberSeparators;

        VAR
            theItl0Handle: Handle;

    BEGIN
        theItl0Handle := GetResource('itl0', GetScript(smSystemScript, smScriptNumber));
        FailNILResource(theItl0Handle);
        WITH Intl0Hndl(theItl0Handle)^^ DO BEGIN
                IF (decimalPt IN ['0'..'9', Char(0), '-']) OR (thousSep IN ['0'..'9', '-']) OR (decimalPt = thousSep) THEN
                    FailOSErr(paramErr);
                gDefaultDecimalSeparator := decimalPt;
                gDefaultThousandsSeparator := thousSep;
            END;
    END;


    PROCEDURE LocalizeNumberString (VAR theString: Str255);

        VAR
            boundary: Integer;
            separatorString: STRING[1];
            minusOffset: Integer;

    BEGIN
        separatorString := ',';
        separatorString[1] := gDefaultThousandsSeparator;

        boundary := Pos('.', theString);
        IF boundary <> 0 THEN
            theString[boundary] := gDefaultDecimalSeparator
        ELSE
            boundary := Length(theString) + 1;

        IF gDefaultThousandsSeparator <> Char(0) THEN BEGIN
                IF theString[1] = '-' THEN
                    minusOffset := 1
                ELSE
                    minusOffset := 0;
                WHILE boundary > 4 + minusOffset DO BEGIN
                        theString := Concat(Copy(theString, 1, boundary - 4), separatorString, Copy(theString, boundary - 3, Length(theString) - boundary + 4));
                        boundary := boundary - 3;
                    END;
            END;
    END;


    PROCEDURE IntegerToLocalString (theNumber: LongInt; VAR theString: Str255);

    BEGIN
        NumToString(theNumber, theString);
        LocalizeNumberString(theString);
    END;


    PROCEDURE ExtendedToLocalString (theNumber: Extended; decimalDigits: Integer; VAR theString: Str255);

        VAR
            theDecForm: DecForm;

    BEGIN
        WITH theDecForm DO BEGIN
                style := fixedDecimal;
                digits := decimalDigits;
            END;
        Num2Str(theDecForm, theNumber, DecStr(theString));
        LocalizeNumberString(theString);
    END;


    VAR
        gUserNumberPartsTable: NumberPartsPtr;
        gReferenceNumberPartsTable: NumberPartsPtr;


    VAR
        gSystemVersion: LongInt;


    FUNCTION GetUserItl4: Handle;

        VAR
            theItl4Handle: Handle;
            systemScript: ScriptCode;
            tableOffset, tableLength: LongInt;
            theItl0Handle: Handle;
            theResID: Integer;
            theResType: ResType;
            theResName: Str255;

    BEGIN

        IF gSystemVersion >= $0710 THEN BEGIN
                systemScript := GetEnvirons(smSysScript);
                IUGetItlTable(systemScript, iuNumberPartsTable, theItl4Handle, tableOffset, tableLength);
                FailNILResource(theItl4Handle);
            END

        ELSE BEGIN
                theItl0Handle := IUGetIntl(0);
                FailNILResource(theItl0Handle);
                GetResInfo(theItl0Handle, theResID, theResType, theResName);
                theItl4Handle := GetResource('itl4', theResID);

                IF ResError = resNotFound THEN BEGIN
                        CASE theResID OF
                            6:
                                theResID := 5;    { Netherlands }
                            30777, 56, 57:
                                theResID := 30776; { Czechoslovakia }
                            OTHERWISE
                                theResID := verUS;
                        END;
                        theItl4Handle := GetResource('itl4', theResID);
                        FailNILResource(theItl4Handle);
                    END
                ELSE
                    FailNILResource(theItl4Handle);
            END;
        GetUserItl4 := theItl4Handle;
    END;


    PROCEDURE CheckDefaultNumberSeparators (userNumberPartsTable: NumberPartsPtr);

        CONST
            testString = '0';

        VAR
            formatRecord: NumFormatString;
            result: FormatStatus;

    BEGIN
        result := Str2Format(testString, userNumberPartsTable^, formatRecord);
        IF FormatResultType(result) <> fFormatOK THEN
            FailOSErr(paramErr);
    END;


    FUNCTION ExtractNumberPartsTable (theItl4Handle: Handle): NumberPartsPtr;

        VAR
            tableOffset, tableLength: LongInt;
            theTable: Ptr;

    BEGIN
        WITH NItl4Handle(theItl4Handle)^^ DO BEGIN
                tableOffset := defPartsOffset;
                tableLength := defPartsLength;
            END;
        theTable := NewPtr(tableLength);
        FailNil(theTable);
        LoadResource(theItl4Handle); { Might have been purged since we got hold of it }
        FailResError;
        BlockMove(Ptr(LongInt(theItl4Handle^) + tableOffset), theTable, tableLength);
        ExtractNumberPartsTable := NumberPartsPtr(theTable);
    END;


    PROCEDURE InitializeNumberPartsTables;

        VAR
            userItl4, usItl4: Handle;

    BEGIN
        userItl4 := GetUserItl4;
        usItl4 := GetResource('itl4', verUS);
        FailNILResource(usItl4);
        gUserNumberPartsTable := ExtractNumberPartsTable(userItl4);
        CheckDefaultNumberSeparators(gUserNumberPartsTable);

        IF (usItl4 = userItl4) AND ((gSystemVersion < $0710) OR ((gDefaultDecimalSeparator = '.') AND (gDefaultThousandsSeparator = ','))) THEN
            gReferenceNumberPartsTable := gUserNumberPartsTable
        ELSE BEGIN
                gReferenceNumberPartsTable := ExtractNumberPartsTable(usItl4);
                gReferenceNumberPartsTable^.data[tokDecPoint].a[1] := '.';
                gReferenceNumberPartsTable^.data[tokThousands].a[1] := ',';
            END;
    END;


    PROCEDURE DisposeNumberPartsTables;

    BEGIN
        IF gReferenceNumberPartsTable <> gUserNumberPartsTable THEN
            DisposPtr(Ptr(gReferenceNumberPartsTable));
        DisposPtr(Ptr(gUserNumberPartsTable));
        gReferenceNumberPartsTable := NIL;
        gUserNumberPartsTable := NIL;
    END;


    PROCEDURE StringToFormatRecord (formatString: Str255; useAlternateNumerals: Boolean; theNumberPartsTable: NumberPartsPtr; VAR formatRecord: NumFormatString);

        VAR
            result: FormatStatus;
            oldChar: WideChar;
            i: Integer;

    BEGIN
        IF useAlternateNumerals THEN BEGIN
                oldChar := theNumberPartsTable^.data[tokNonLeader];
                theNumberPartsTable^.data[tokNonLeader].b := Ord('1');
                FOR i := 1 TO Length(formatString) DO
                    IF formatString[i] = '#' THEN
                        formatString[i] := '1';
            END;
        result := Str2Format(formatString, theNumberPartsTable^, formatRecord);
        IF useAlternateNumerals THEN
            theNumberPartsTable^.data[tokNonLeader] := oldChar;
        IF FormatResultType(result) <> fFormatOK THEN
            FailOSErr(paramErr);
    END;


    FUNCTION HasAlternateNumerals (aNumberPartsTable: NumberPartsPtr): Boolean;

    BEGIN
        HasAlternateNumerals := aNumberPartsTable^.altNumTable.data[0].b <> Ord('0');
    END;


    PROCEDURE PredefinedStringToFormatRecord (predefinedFormatString: Str255; useAlternateNumerals: Boolean; VAR formatRecord: NumFormatString);

    BEGIN
        StringToFormatRecord(predefinedFormatString, useAlternateNumerals, gReferenceNumberPartsTable, formatRecord);
    END;


    PROCEDURE FormatRecordToUserString (formatRecord: NumFormatString; VAR userFormatString: Str255);

        VAR
            result: FormatStatus;
            positions: TripleInt;

    BEGIN
        result := Format2Str(formatRecord, gUserNumberPartsTable^, userFormatString, positions);
        IF FormatResultType(result) <> fFormatOK THEN
            FailOSErr(paramErr);
    END;


    PROCEDURE UserStringToFormatRecord (userFormatString: Str255; useAlternateNumerals: Boolean; VAR formatRecord: NumFormatString);

    BEGIN
        StringToFormatRecord(userFormatString, useAlternateNumerals, gUserNumberPartsTable, formatRecord);
    END;


    PROCEDURE FormatNumber (theNumber: Extended; theFormatRecord: NumFormatString; VAR theString: Str255);

        VAR
            result: FormatStatus;

    BEGIN
        result := FormatX2Str(theNumber, theFormatRecord, gUserNumberPartsTable^, theString);
        IF FormatResultType(result) <> fFormatOK THEN
            FailOSErr(paramErr);
    END;


    PROCEDURE UnlocalizeNumberString (VAR theString: Str255; allowDecimal: Boolean);

        VAR
            delta: Integer;
            i: Integer;
            theChar: Char;

    BEGIN
        delta := 0;
        FOR i := 1 TO Length(theString) DO BEGIN
                theChar := theString[i];
                IF (theChar >= '0') & (theChar <= '9') THEN
                    theString[i - delta] := theChar
                ELSE IF (theChar = '-') & (i = 1) THEN
                    theString[i - delta] := theChar
                ELSE IF theChar = gDefaultThousandsSeparator THEN
                    delta := delta + 1
                ELSE IF theChar = gDefaultDecimalSeparator THEN BEGIN
                        IF allowDecimal THEN BEGIN
                                allowDecimal := FALSE; { one is enough }
                                theString[i - delta] := '.';
                            END
                        ELSE
                            FailOSErr(paramErr)
                    END
                ELSE
                    FailOSErr(paramErr);
            END;
        theString[0] := Char(Length(theString) - delta);
        IF Length(theString) = 0 THEN
            FailOSErr(paramErr);
    END;


    PROCEDURE LocalStringToInteger (theString: Str255; VAR theNumber: LongInt);

    BEGIN
        UnlocalizeNumberString(theString, FALSE);
        StringToNum(theString, theNumber);
    END;


    PROCEDURE LocalStringToExtended (theString: Str255; VAR theNumber: Extended);

    BEGIN
        UnlocalizeNumberString(theString, TRUE);
        theNumber := Str2Num(theString);
    END;


    FUNCTION InterpretExtended (theString: Str255; theFormatRecord: NumFormatString; VAR theNumber: Extended): Boolean;

        VAR
            result: FormatStatus;

    BEGIN
        result := FormatStr2X(theString, theFormatRecord, gUserNumberPartsTable^, theNumber);
        InterpretExtended := FormatResultType(result) = fFormatOK;
    END;


    FUNCTION InterpretInteger (theString: Str255; theFormatRecord: NumFormatString; VAR theNumber: LongInt): Boolean;

        VAR
            result: FormatStatus;
            theExtended: Extended;

        CONST
            minLongInt = -2147483648;
            maxLongInt = 2147483647;

    BEGIN
        result := FormatStr2X(theString, theFormatRecord, gUserNumberPartsTable^, theExtended);
        IF (FormatResultType(result) = fFormatOK) & (theExtended >= minLongInt) & (theExtended <= maxLongInt) THEN BEGIN
                theNumber := Num2LongInt(theExtended);
                InterpretInteger := TRUE;
            END
        ELSE
            InterpretInteger := FALSE;
    END;


    PROCEDURE CheckConfiguration;

        VAR
            response: LongInt;

    BEGIN
        FailOSErr(Gestalt(gestaltSystemVersion, response));
        gSystemVersion := response; { uses low word only }
        IF gSystemVersion < $0700 THEN BEGIN
                Writeln('### This sample requires at least System 7.0');
                ExitProgram;
            END;
    END;


    PROCEDURE FailEOF;

    BEGIN
        IF EOF THEN BEGIN
                Writeln('### encountered end of file');
                ExitProgram;
            END;
    END;


    PROCEDURE DoDefaultFormattingTest;

        PROCEDURE WriteDefaultInteger (theNumber: LongInt);
            VAR
                theString: Str255;
        BEGIN
            IntegerToLocalString(theNumber, theString);
            Writeln(theString);
        END;

        PROCEDURE WriteDefaultExtended (theNumber: Extended);
            VAR
                theString: Str255;
        BEGIN
            ExtendedToLocalString(theNumber, 2, theString);
            Writeln(theString);
        END;

        PROCEDURE ReadDefaultInteger (VAR theInteger: LongInt);
            VAR
                theString: Str255;
        BEGIN
            FailEOF;
            ReadLn(theString);
            LocalStringToInteger(theString, theInteger);
        END;

        PROCEDURE ReadDefaultExtended (VAR theExtended: Extended);
            VAR
                theString: Str255;
        BEGIN
            FailEOF;
            ReadLn(theString);
            LocalStringToExtended(theString, theExtended);
        END;

        VAR
            theLongInt: LongInt;
            theExtended: Extended;

    BEGIN
        WriteLn('Testing default formatting routines:');
        WriteLn('Writing test numbers:');
        WriteDefaultInteger(123);
        WriteDefaultInteger(-123);
        WriteDefaultInteger(1234);
        WriteDefaultInteger(-1234);
        WriteDefaultInteger(-123456789);
        WriteDefaultInteger(0);
        WriteDefaultExtended(123.456);
        WriteDefaultExtended(7123.456);
        WriteDefaultExtended(-123.456);
        WriteDefaultExtended(-7123.456);
        WriteDefaultExtended(-123456789.456);
        WriteDefaultExtended(0);

        Writeln('Please enter integer numbers - 0 will skip to next test');
        REPEAT
            ReadDefaultInteger(theLongInt);
            WriteDefaultInteger(theLongInt);
        UNTIL theLongInt = 0;

        Writeln('Please enter floating point numbers - 0 will skip to next test');
        REPEAT
            ReadDefaultExtended(theExtended);
            WriteDefaultExtended(theExtended);
        UNTIL theExtended = 0.0;

    END;


    CONST
        kUSFloatFormatString = '###,###.##;-###,###.##;0.##';
        kUSIntegerFormatString = '###,###;-###,###;0';
        kUSScientificFormatString = '#.###e+##;-#.###e-##;0.';


    VAR
        theFloatFormatRecord: NumFormatString;
        theIntegerFormatRecord: NumFormatString;
        theScientificFormatRecord: NumFormatString;
        gUseAlternateNumerals: Boolean;


    PROCEDURE DoFormatStringTest;

        VAR
            theString: Str255;

    BEGIN
        WriteLn('Testing format specification conversions:');
        PredefinedStringToFormatRecord(kUSFloatFormatString, gUseAlternateNumerals, theFloatFormatRecord);
        PredefinedStringToFormatRecord(kUSIntegerFormatString, gUseAlternateNumerals, theIntegerFormatRecord);
        PredefinedStringToFormatRecord(kUSScientificFormatString, gUseAlternateNumerals, theScientificFormatRecord);
        FormatRecordToUserString(theFloatFormatRecord, theString);
        Writeln('US float: ', kUSFloatFormatString);
        Writeln('user float: ', theString);
        FormatRecordToUserString(theIntegerFormatRecord, theString);
        Writeln('US integer: ', kUSIntegerFormatString);
        Writeln('user integer: ', theString);
        FormatRecordToUserString(theScientificFormatRecord, theString);
        Writeln('US scientific: ', kUSScientificFormatString);
        Writeln('user scientific: ', theString);
    END;


    PROCEDURE DoCustomizedFormattingTest;

        CONST
            kExtendedInputFormatString = '###,###.##;(###,###.##);0.##';
            kIntegerInputFormatString = '#,###,###,###;(#,###,###,###);0';

        PROCEDURE WriteExtended (theNumber: Extended);
            VAR
                theString: Str255;
        BEGIN
            FormatNumber(theNumber, theScientificFormatRecord, theString);
            Writeln(theString);
        END;

        FUNCTION ReadExtended (VAR theNumber: Extended): Boolean;
            VAR
                theString: Str255;
                theFormatRecord: NumFormatString;
        BEGIN
            FailEOF;
            ReadLn(theString);
            PredefinedStringToFormatRecord(kExtendedInputFormatString, gUseAlternateNumerals, theFormatRecord);
            ReadExtended := InterpretExtended(theString, theFormatRecord, theNumber);
        END;

        PROCEDURE WriteInteger (theNumber: Extended);
            VAR
                theString: Str255;
                theFormatRecord: NumFormatString;
        BEGIN
            FormatNumber(theNumber, theIntegerFormatRecord, theString);
            Writeln(theString);
        END;

        FUNCTION ReadInteger (VAR theNumber: LongInt): Boolean;
            VAR
                theString: Str255;
                theFormatRecord: NumFormatString;
        BEGIN
            FailEOF;
            ReadLn(theString);
            PredefinedStringToFormatRecord(kIntegerInputFormatString, gUseAlternateNumerals, theFormatRecord);
            ReadInteger := InterpretInteger(theString, theFormatRecord, theNumber);
        END;

        VAR
            theExtended: Extended;
            theLongInt: LongInt;

    BEGIN
        WriteLn('Testing user-specified formatting routines:');
        WriteLn('Writing test numbers:');
        WriteExtended(3.1415926);
        WriteExtended(-3.1415926);
        WriteExtended(0);
        WriteInteger(1024);
        WriteInteger(-1024);
        WriteInteger(0);

        Writeln('Please enter integer numbers - 0 will skip to next test');
        REPEAT
            IF ReadInteger(theLongInt) THEN BEGIN
                    IF Abs(theLongInt) < 999999 THEN
                        WriteInteger(theLongInt)
                    ELSE
                        WriteLn('### Can''t display this number!')
                END
            ELSE BEGIN
                    WriteLn('### Can''t interpret this number!');
                    theLongInt := 1; { to keep running }
                END;
        UNTIL theLongInt = 0;

        Writeln('Please enter floating point numbers - 0', gDefaultDecimalSeparator, '0 will end test');
        REPEAT
            IF ReadExtended(theExtended) THEN BEGIN
                    IF Abs(theExtended) < 999999.995 THEN
                        WriteExtended(theExtended)
                    ELSE
                        WriteLn('### Can''t display this number!');
                END
            ELSE BEGIN
                    WriteLn('### Can''t interpret this number!');
                    theExtended := 1.0; { to keep running }
                END;
        UNTIL theExtended = 0.0;

    END;


    VAR
        answer: Str255;


BEGIN

    CheckConfiguration;
    InitializeDefaultNumberSeparators;
    InitializeNumberPartsTables;
    IF HasAlternateNumerals(gUserNumberPartsTable) THEN BEGIN
            Writeln('Use alternate numerals [y/n]?');
            FailEOF;
            ReadLn(answer);
            gUseAlternateNumerals := (Length(answer) > 0) & (answer[1] IN ['y', 'Y']);
        END
    ELSE
        gUseAlternateNumerals := FALSE;
    DoDefaultFormattingTest;
    DoFormatStringTest;
    DoCustomizedFormattingTest;
    DisposeNumberPartsTables;

END.